home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / psd.zip / READ.SCM < prev    next >
Text File  |  1992-07-09  |  17KB  |  654 lines
  1. ;;;;
  2. ;;;; read.scm 1.17
  3. ;;;;
  4. ;;;; psd -- a portable Scheme debugger, version 1.0
  5. ;;;; Copyright (C) 1992 Pertti Kellomaki, pk@cs.tut.fi
  6.  
  7. ;;;; This program is free software; you can redistribute it and/or modify
  8. ;;;; it under the terms of the GNU General Public License as published by
  9. ;;;; the Free Software Foundation; either version 1, or (at your option)
  10. ;;;; any later version.
  11.  
  12. ;;;; This program is distributed in the hope that it will be useful,
  13. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15. ;;;; GNU General Public License for more details.
  16.  
  17. ;;;; You should have received a copy of the GNU General Public License
  18. ;;;; along with this program; if not, write to the Free Software
  19. ;;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. ;;;; See file COPYING in the psd distribution.
  21.  
  22. ;;;; 
  23. ;;;; Written by Pertti Kellomaki, pk@cs.tut.fi
  24. ;;;;
  25. ;;;; This file contains the reader for psd. We can not use plain read,
  26. ;;;; because we want to know where in a file we are. The reader
  27. ;;;; returns a pexp, which is a sexp with position information.
  28. ;;;;
  29.  
  30. ;;;----------------------------------------------------------------------
  31. ;;; modification: egb (edward briggs (briggs@getoff.dec.com)) added support 
  32. ;;                for binary, octal and hex numbers. (e.g. #b0101, #o77, #xa0).
  33. ;;              1) added predicates digit-2? digit-8? digit-16?
  34. ;;              2) added routines read-hex-number, read binary-number, and
  35. ;;                 read-octal-number 
  36. ;;              3) added lines to read-hashed-token to find these numbers
  37. ;;
  38. ;;----------------------------------------------------------------------
  39.  
  40. ;;; Current position in the source file. These are updated from
  41. ;;; elsewhere. Not nice, should do it some other way.  
  42.  
  43. (define *psd-source-line-number* 1)
  44. (define *psd-source-char-position* 1)
  45.  
  46. ;;; In order to save space, path names are stored as integers in the
  47. ;;; instrumented file. psd-path->index and psd-index->path do the
  48. ;;; conversion.
  49.  
  50. (define psd-path->index #f)
  51. (define psd-index->path #f)
  52.  
  53. (let ((path-names '())
  54.       (count -1))
  55.   
  56.   (set! psd-path->index
  57.     (lambda (str)
  58.       (let ((result (assoc str path-names)))
  59.         (if (not result)
  60.         (begin
  61.           (set! count (+ count 1))
  62.           (set! path-names
  63.             `((,count . ,str)
  64.               (,str . ,count)
  65.               ,@path-names))
  66.           count)
  67.         (cdr result)))))
  68.   
  69.   (set! psd-index->path
  70.     (lambda (index)
  71.       (cdr (assoc index path-names)))))
  72.  
  73. ;;;
  74. ;;; Read an expression from the port, and tag it with the given source
  75. ;;; file name and position information.
  76.  
  77.  
  78. (define psd-read
  79.   
  80.   (let ((+ +) (- -) (= =) (boolean? boolean?) (caddr caddr) (cadr cadr)
  81.           (car car) (cddr cddr) (cdr cdr)
  82.           (char-whitespace? char-whitespace?) (char=? char=?)
  83.           (char? char?) (cons cons) (eof-object? eof-object?)
  84.           (eq? eq?) (equal? equal?) (error error) 
  85.           (length length) (list list) (list->string list->string)
  86.           (member member) (not not) (null? null?) (number? number?)
  87.           (peek-char peek-char) (read read) (read-char read-char)
  88.           (reverse reverse) (string->number string->number)
  89.           (string->symbol string->symbol) (string-append string-append)
  90.           (string-ci=? string-ci=?) (string? string?) (symbol? symbol?))
  91.     
  92.     (lambda (port source-file-name)
  93.       
  94. ;;;
  95. ;;; Read a character and update position.
  96. ;;;
  97.       
  98.       (define (get-char)
  99.     (let ((char (read-char port)))
  100.       (cond ((eof-object? char) char)
  101.         (else
  102.          (case char
  103.            ((#\newline)
  104.             (set! *psd-source-char-position* 0)
  105.             (set! *psd-source-line-number* (+ *psd-source-line-number* 1)))
  106.            (else
  107.             (set! *psd-source-char-position* (+ *psd-source-char-position* 1))))
  108.          char))))
  109.       
  110. ;;;
  111. ;;; Look at the next character.
  112. ;;;
  113.       
  114.       (define (next-char) (peek-char port))
  115.       
  116. ;;;
  117. ;;; Is the next character one of the given ones?
  118. ;;;
  119.       
  120.       (define (next? . chars)
  121.     (member (next-char) chars))
  122.       
  123. ;;;
  124. ;;; Build a list describing the current position
  125. ;;;
  126.       
  127.       (define (current-position)
  128.     (list (psd-path->index source-file-name)
  129.           *psd-source-line-number*
  130.           *psd-source-char-position*))
  131. ;;;
  132. ;;; Tokens. The starting and ending positions are supplied with
  133. ;;; each token.
  134. ;;;
  135.       
  136.       (define (make-token start end contents) (list start end contents))
  137.       (define (token-start tok) (car tok))
  138.       (define (token-end tok) (cadr tok))
  139.       (define (token-contents tok) (caddr tok))
  140.       
  141. ;;;
  142. ;;; These are used for some special tokens.
  143. ;;;
  144.       
  145.       (define left-paren '(left-paren))
  146.       (define right-paren '(right-paren))
  147.       (define vector-start '(vector-start))
  148.       (define dot '(dot))
  149.       (define quote-token '(quote))
  150.       (define quasiquote-token '(quasiquote))
  151.       (define unquote-token '(unquote))
  152.       (define unquote-splicing-token '(unquote-splicing))
  153.       (define line-directive-token '(line-directive))
  154.       
  155. ;;;
  156. ;;; Classify characters. See R4RS Formal syntax (7.1)
  157. ;;;
  158.       
  159.       (define (letter? c)
  160.     (member c '(#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m #\n
  161.             #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z #\A
  162.             #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M #\N
  163.             #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z)))
  164.       
  165.       (define (special-initial? c)
  166.     (member c '(#\! #\$ #\% #\& #\* #\/ #\: #\< #\= #\> #\? #\~ #\_ #\^)))
  167.       
  168.       (define (initial? c)
  169.     (or (letter? c) (special-initial? c)))
  170.       
  171.       (define (digit? c)
  172.     (member c '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0)))
  173.       
  174.       (define (digit-2? c)
  175.     (member c '(#\0 #\1)))
  176.       
  177.       (define (digit-8? c)
  178.     (member c '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7)))
  179.       
  180.       (define (digit-16? c)
  181.     (member c '(#\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\0 #\a #\b
  182.             #\c #\d #\e #\f #\A #\B #\C #\D #\E #\F)))
  183.       
  184.       (define (special-subsequent? c)
  185.     (member c '(#\. #\+ #\- )))
  186.       
  187.       (define (subsequent? c)
  188.     (or (initial? c) (digit? c) (special-subsequent? c)))
  189.       
  190. ;;;
  191. ;;; Skip white space.
  192. ;;;
  193.       
  194.       (define (skip-white-space)
  195.     (if (eof-object? (next-char))
  196.         #f
  197.         (cond
  198.          ((char-whitespace? (next-char))
  199.           (get-char)
  200.           (skip-white-space))
  201.          ((next? #\;)
  202.           (let loop ()
  203.         (cond ((eof-object? (next-char))
  204.                #f)
  205.               ((next? #\newline)
  206.                (skip-white-space))
  207.               (else
  208.                (get-char)
  209.                (loop))))))))
  210.       
  211.       
  212. ;;;
  213. ;;; Read next token.
  214. ;;;
  215.       
  216.       (define (read-token)
  217.     (skip-white-space)
  218.     (if (equal? (next-char) #\#)
  219.         
  220.         ;; If it starts with a hash sign, it might be a line
  221.         ;; directive. In that case, just read the next token.
  222.         (let* ((start (current-position))
  223.            (contents (read-hashed-token))
  224.            (end (current-position)))
  225.           (if (eq? contents line-directive-token)
  226.           (read-token)
  227.           (make-token start end contents)))
  228.         
  229.         (let* ((start (current-position))
  230.            (contents
  231.             (cond
  232.              ((eof-object? (next-char))
  233.               (get-char))
  234.              ((initial? (next-char))
  235.               (read-identifier))
  236.              ((next? #\+ #\- #\.)
  237.               (maybe-read-peculiar-identifier))
  238.              ((digit? (next-char))
  239.               (read-number))
  240.              ((next? #\()
  241.               (get-char)
  242.               left-paren)
  243.              ((next? #\))
  244.               (get-char)
  245.               right-paren)
  246.              ((next? #\')
  247.               (get-char)
  248.               quote-token)
  249.              ((next? #\`)
  250.               (get-char)
  251.               quasiquote-token)
  252.              ((next? #\,)
  253.               (get-char)
  254.               (if (next? #\@)
  255.               (begin (get-char)
  256.                  unquote-splicing-token)
  257.               unquote-token))
  258.              ((next? #\")
  259.               (read-string))
  260.              (else
  261.               (error "read-token: bad character " (next-char)))))
  262.            (end (current-position)))
  263.           (make-token start end contents))))
  264.       
  265. ;;;
  266. ;;; Read a string.
  267. ;;;
  268.       
  269.       (define (read-string)
  270.     (get-char)
  271.     (let loop ((result '()))
  272.       (cond
  273.        ((next? #\")
  274.         (get-char)
  275.         (list->string (reverse result)))
  276.        ((next? #\\)
  277.         (get-char)
  278.         (loop (cons (get-char) result)))
  279.        (else
  280.         (loop (cons (get-char) result))))))
  281.       
  282. ;;;
  283. ;;; Read a token starting with a hash sign.
  284. ;;;
  285.       
  286.       (define (read-hashed-token)
  287.     (get-char)
  288.     (cond
  289.      ((next? #\t)
  290.       (get-char)
  291.       #t)
  292.      ((next? #\f)
  293.       (get-char)
  294.       #f)
  295.      ((next? #\\)
  296.       (read-character))
  297.      ((or (next? #\x) (next? #\X))
  298.       (get-char)
  299.       (read-hex-number))
  300.      ((or (next? #\b) (next? #\B))
  301.       (get-char)
  302.       (read-binary-number))
  303.      ((or (next? #\o) (next? #\O))
  304.       (get-char)
  305.       (read-octal-number))
  306.  
  307.      ((next? #\()
  308.       (get-char)
  309.       vector-start)
  310.  
  311.      ;; we return a special token to inform that this was not a real
  312.      ;; token but a line directive
  313.      ((next? #\l)
  314.       (read-line-directive)
  315.       line-directive-token)
  316.      
  317.      (else
  318.       (error "read-hashed-token: bad character " (next-char)))))
  319.       
  320.       
  321. ;;;
  322. ;;; Read a line directive, of the form "#line file line column #".
  323. ;;; The trailing hash is used for making sure that we don't run past
  324. ;;; the end of line. At least scm version 3c8 will read one more trailing
  325. ;;; whitespace character than R4RS says it should. In later versions
  326. ;;; this is fixed.
  327. ;;;
  328.       
  329.       (define (read-line-directive)
  330.     (get-char)
  331.     (if (next? #\i)
  332.         (get-char)
  333.         (error "read-line-directive: bad character " (next-char)))
  334.     (if (next? #\n)
  335.         (get-char)
  336.         (error "read-line-directive: bad character " (next-char)))
  337.     (if (next? #\e)
  338.         (get-char)
  339.         (error "read-line-directive: bad character " (next-char)))
  340.     
  341.     ;; now we don't have to worry about loosing count where we are,
  342.     ;; because we are going to read the new position from the file.
  343.     (set! source-file-name (read port))
  344.     (set! *psd-source-line-number* (read port))
  345.     (set! *psd-source-char-position* (read port))
  346.     
  347.     ;; the position corresponds to the start of next line
  348.     (let loop ((next (read-char port)))
  349.       (if (char=? next #\newline)
  350.           #f
  351.           (loop (read-char port)))))
  352.       
  353. ;;;
  354. ;;; Read a character constant.
  355. ;;;
  356.       
  357.       (define (read-character)
  358.     (get-char)
  359.     (let loop ((result (list (get-char))))
  360.       (if (letter? (next-char))
  361.           (loop (cons (get-char) result))
  362.           (cond ((= (length result) 1)
  363.              (car result))
  364.             (else
  365.              (let ((name (list->string (reverse result))))
  366.                (cond ((string-ci=? name "space") #\space)
  367.                  ((string-ci=? name "newline") #\newline)
  368.                  (else (error "read-character: character name not defined in R4RS "
  369.                       name)))))))))
  370.       
  371.  
  372. ;;;
  373. ;;; Read a vector constant.
  374. ;;;
  375.  
  376.       (define (read-vector start-token)
  377.     (let loop ((contents '())
  378.            (this (internal-read)))
  379.       (cond ((eof-object? this)
  380.          (error "read-vector: premature end of file"))
  381.         ((eq? (psd-expr-type this) 'right-paren)
  382.          (psd-make-vector (psd-expr-start start-token)
  383.                   (psd-expr-end this)
  384.                   (reverse contents)))
  385.         (else (loop (cons this contents)
  386.                 (internal-read))))))
  387.  
  388. ;;;
  389. ;;; Read a normal identifier.
  390. ;;;
  391.       
  392.       (define (read-identifier)
  393.     (let loop ((result (list (get-char))))
  394.       (if (subsequent? (next-char))
  395.           (loop (cons (get-char) result))
  396.           (string->symbol (list->string (reverse result))))))
  397.       
  398. ;;;
  399. ;;; Read a peculiar identifier (+ - ... or a single dot)
  400. ;;; 
  401.       
  402.       (define (maybe-read-peculiar-identifier)
  403.     (let ((first (get-char)))
  404.       (case first
  405.         ((#\+)
  406.          (if (digit? (next-char))
  407.          (read-number)
  408.          '+))
  409.         ((#\-)
  410.          (if (digit? (next-char))
  411.          (- (read-number))
  412.          '-))
  413.         ((#\.)
  414.          (if (next? #\.)
  415.          (if (and (get-char)
  416.               (next? #\.)
  417.               (get-char))
  418.              '...
  419.              (error "The only identifier that may start with dot is ..."))
  420.          dot)))))
  421.       
  422. ;;;
  423. ;;; Read a number. Handles only integers and floats without exponents.
  424. ;;;
  425.       
  426.       (define (read-number)
  427.     
  428.     (define (read-sign)
  429.       (cond ((or (next? #\+)
  430.              (next? #\-))
  431.          (string (get-char)))
  432.         (else "")))
  433.     
  434.     (define (uinteger)
  435.       (let loop ((result '()))
  436.         (if (or (digit? (next-char))
  437.             (next? #\#))
  438.         (loop (cons (get-char) result))
  439.         (list->string (reverse result)))))
  440.  
  441.     (define (exponent-marker)
  442.       (cond ((or (next? #\e)
  443.              (next? #\s)
  444.              (next? #\f)
  445.              (next? #\d)
  446.              (next? #\l))
  447.          (string (get-char)))
  448.         (else "")))
  449.     
  450.     (let* ((sign (read-sign))
  451.            (integer-part (uinteger))
  452.            (fractional-part
  453.         (if (next? #\.)
  454.             (begin
  455.               (get-char)
  456.               (string-append "." (uinteger)))
  457.             ""))
  458.            (marker (exponent-marker))
  459.            (exponent
  460.         (if (string=? "" marker)
  461.             ""
  462.             (string-append marker(uinteger)))))
  463.       
  464.       (string->number (string-append sign
  465.                      integer-part
  466.                      fractional-part
  467.                      exponent))))
  468.       
  469.       
  470. ;;;
  471. ;;; Support for hex, octal and binary.
  472. ;;; Added by egb.
  473. ;;; 
  474.       
  475.       (define (read-binary-number)
  476.     (define (binaryinteger)
  477.       (let loop ((result '()))
  478.         (if (digit-2? (next-char))
  479.         (loop (cons (get-char) result))
  480.         (list->string (reverse result)))))
  481.     (string->number (string-append "#b" (binaryinteger))))
  482.       
  483.       (define (read-octal-number)
  484.     (define (octalinteger)
  485.       (let loop ((result '()))
  486.         (if (digit-8? (next-char))
  487.         (loop (cons (get-char) result))
  488.         (list->string (reverse result)))))
  489.     (string->number (string-append "#o" (octalinteger))))
  490.       
  491.       
  492.       (define (read-hex-number)
  493.     (define (hexinteger)
  494.       (let loop ((result '()))
  495.         (if (digit-16? (next-char))
  496.         (loop (cons (get-char) result))
  497.         (list->string (reverse result)))))
  498.     
  499.     (string->number (string-append "#x" (hexinteger))))
  500.       
  501.       
  502. ;;;
  503. ;;; Read a list up to the ending paren.
  504. ;;;
  505.       
  506.       (define (read-list starting-paren)
  507.     
  508.     (define (list->plist lst start end)
  509.       (cond
  510.        
  511.        ;; end of list
  512.        ((null? lst)
  513.         (psd-make-null start end))
  514.        
  515.        ;; dotted pair, there should be exactly one expression after the dot
  516.        ((eq? (psd-expr-type (car lst)) 'dot)
  517.         (cond ((or (null? (cdr lst))
  518.                (not (null? (cddr lst))))
  519.            (error "Bad dotted pair."))
  520.           (else (cadr lst))))
  521.        (else
  522.         (psd-cons (car lst)
  523.               (list->plist (cdr lst)
  524.                    (if (null? (cdr lst))
  525.                        end
  526.                        (psd-expr-start (cadr lst)))
  527.                    end)
  528.               start
  529.               end))))
  530.     
  531.     
  532.     
  533.     (let loop ((result '())
  534.            (this (internal-read)))
  535.       (cond
  536.        
  537.        ;; the list ended
  538.        ((eq? (psd-expr-type this) 'right-paren)
  539.         (list->plist (reverse result)
  540.              (psd-expr-start starting-paren)
  541.              (psd-expr-end this)))
  542.        
  543.        ;; continue reading
  544.        (else
  545.         (loop (cons this result)
  546.           (internal-read))))))
  547.       
  548.       
  549.       
  550.       
  551. ;;;
  552. ;;; The reader proper.
  553. ;;;
  554.       
  555.       (define (internal-read)
  556.     (let* ((token (read-token))
  557.            (contents (token-contents token)))
  558.       (cond
  559.        
  560.        ((eq? contents left-paren)
  561.         (read-list token))
  562.        ((eq? contents vector-start)
  563.         (read-vector token))
  564.        ((symbol? contents)
  565.         (psd-make-symbol
  566.          (token-start token)
  567.          (token-end token)
  568.          contents))
  569.        ((number? contents)
  570.         (psd-make-number
  571.          (token-start token)
  572.          (token-end token)
  573.          contents))
  574.        ((char? contents)
  575.         (psd-make-char
  576.          (token-start token)
  577.          (token-end token)
  578.          contents))
  579.        ((eq? contents right-paren)
  580.         (psd-make-expr 'right-paren
  581.                (token-start token)
  582.                (token-end token)
  583.                contents))
  584.        ((eq? contents dot)
  585.         (psd-make-expr 'dot
  586.                (token-start token)
  587.                (token-end token)
  588.                contents))
  589.        ((eq? contents quote-token)
  590.         (let ((quoted-expr (internal-read)))
  591.           (psd-cons (psd-make-symbol (token-start token)
  592.                      (token-end token)
  593.                      'quote)
  594.             (psd-cons quoted-expr
  595.                   (psd-make-null (psd-expr-end quoted-expr)
  596.                          (psd-expr-end quoted-expr))
  597.                   (psd-expr-start quoted-expr)
  598.                   (psd-expr-end quoted-expr))
  599.             (psd-expr-start quoted-expr)
  600.             (psd-expr-end quoted-expr))))
  601.        ((eq? contents quasiquote-token)
  602.         (let ((quasiquoted-expr (internal-read)))
  603.           (psd-cons (psd-make-symbol (token-start token)
  604.                      (token-end token)
  605.                      'quasiquote)
  606.             (psd-cons quasiquoted-expr
  607.                   (psd-make-null (psd-expr-end quasiquoted-expr)
  608.                          (psd-expr-end quasiquoted-expr))
  609.                   (psd-expr-start quasiquoted-expr)
  610.                   (psd-expr-end quasiquoted-expr))
  611.             (psd-expr-start quasiquoted-expr)
  612.             (psd-expr-end quasiquoted-expr))))
  613.        ((eq? contents unquote-token)
  614.         (let ((unquoted-expr (internal-read)))
  615.           (psd-cons (psd-make-symbol (token-start token)
  616.                      (token-end token)
  617.                      'unquote)
  618.             (psd-cons unquoted-expr
  619.                   (psd-make-null (psd-expr-end unquoted-expr)
  620.                          (psd-expr-end unquoted-expr))
  621.                   (psd-expr-start unquoted-expr)
  622.                   (psd-expr-end unquoted-expr))
  623.             (psd-expr-start unquoted-expr)
  624.             (psd-expr-end unquoted-expr))))
  625.        ((eq? contents unquote-splicing-token)
  626.         (let ((unquoted-expr (internal-read)))
  627.           (psd-cons (psd-make-symbol (token-start token)
  628.                      (token-end token)
  629.                      'unquote-splicing)
  630.             (psd-cons unquoted-expr
  631.                   (psd-make-null (psd-expr-end unquoted-expr)
  632.                          (psd-expr-end unquoted-expr))
  633.                   (psd-expr-start unquoted-expr)
  634.                   (psd-expr-end unquoted-expr))
  635.             (psd-expr-start unquoted-expr)
  636.             (psd-expr-end unquoted-expr))))
  637.        
  638.        ((boolean? contents)
  639.         (psd-make-boolean
  640.          (token-start token)
  641.          (token-end token)
  642.          contents))
  643.        ((string? contents)
  644.         (psd-make-string
  645.          (token-start token)
  646.          (token-end token)
  647.          contents))
  648.        ((eof-object? contents)
  649.         contents))))
  650.       
  651.       
  652.       ;; body of psd-read
  653.       (internal-read))))
  654.